perm filename EDIT.113[AID,LSP] blob
sn#668564 filedate 1982-07-15 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00029 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002 ************************************************************
C00011 00003 (DEFUN IMPCOND MACRO (X)
C00013 00004 *(programspace 45.)
C00017 00005 (DEFUN EDIT FEXPR (X)
C00023 00006 (DEFUN %EVAL-NUMBER (%COMMAND)
C00025 00007 match attempts to match the last pattern against the CE
C00032 00008 (match ?pat *vars) attempts to match ?pat against CE retaining the
C00036 00009 ((COMMAND= (B ($R ?%N NUMBERP) *%X))
C00043 00010 functions to move around the tree
C00047 00011 functions for inserting stuff
C00049 00012 deleting functions
C00051 00013 undoing functions
C00054 00014 functions to initialize the
C00058 00015 (DEFUN %GETDEF1 (NAME)
C00059 00016 functions for replacing forms
C00061 00017 (DEFUN %STRINGSUB (OLDLIST NEWLIST WORD)
C00062 00018 functions for reforming the ce
C00065 00019 searching functions
C00069 00020 the matching function
C00073 00021 The Matcher & friends normally appear in this slot.
C00075 00022 marking functions
C00078 00023 utility functions
C00082 00024 functions for reading & writing on dsk
C00093 00025 (DECLARE (SPECIAL TO-REFILE REFILE-ALL UPDATED))
C00101 00026 (DEFUN %FLUSHCOMMENTS (L)
C00104 00027 (DEFUN %EDIT-HELP NIL
C00106 00028 (DEFPROP EDIT
C00109 00029 (PROG (FILE)
C00111 ENDMK
C⊗;
;;; ************************************************************
;;; ****** LISP EDITOR **************************************
;;; ****** SAIL **************************************
;;; ****** COPYRIGHT 1982 **************************************
;;; ************************************************************
(declare (setsyntax 35. 2 35.))
(DECLARE (EVAL (READ)))
(SETSYNTAX '/[ 'SPLICING ;CONDITIONAL ASSEMBLY HACK
(FUNCTION (LAMBDA NIL ;LOOK SORT OF LIKE MIDAS IF'S
((LAMBDA (IF FLAG R)
(COND ((ATOM FLAG)(SETQ FLAG (NCONS FLAG))))
(COND ((EQ IF 'IFE))
((EQ IF 'IFN) (SETQ IF NIL))
((EQ IF 'IFP) (SETQ IF (EVAL FLAG) FLAG NIL))
((BREAK LOSING-IF T)))
(OR (APPLY 'AND (MAPCAR (FUNCTION (LAMBDA (Q)
(COND ((ATOM Q)
(COND ((MEMQ Q R) T)))
(T (COND ((APPLY (CAR Q)
(NCONS (MEMQ (CADR Q) R))) T))))))
FLAG))
(SETQ IF (NOT IF)))
(AND IF (DO ((Z (TYIPEEK) (TYIPEEK)) (N 1))
((ZEROP N))
(COND ((= Z '133) (SETQ N (1+ N)))
((= Z '135) (SETQ N (1- N))))(TYI))))
(READ) (READ)(STATUS FEATURES))
NIL)))
(DECLARE (EVAL (READ)))
(SETSYNTAX '/] 'SPLICING (FUNCTION (LAMBDA NIL NIL))) ;RIGHT BRACE
(DECLARE ;(EXPR-HASH T)
(MAPEX T)
[IFN SAIL (*EXPR INITED LOADED ADDED)(FIXNUM %%NEXT-SYM%%)]
; (NOARGS T)
(MACROS NIL)
(GENPREFIX %EDIT)
(*EXPR %INSTANTIATE ;%CHAR1
)
(*FEXPR EDIT %TOUNDO: EDITCOMMAND %DATA-INIT EDIT2 [IFN SAIL BEEP])
(*LEXPR %P %MATCH %CONTINUE-MATCH)
(*FEXPR GRINDMACRO IOC)
(FIXNUM (%LENGTH) %EDIT-PRINDEPTH %EDIT-PRINLENGTH)
(SPECIAL LINEL CHRCT)
(SPECIAL GRINDREADTABLE /; |;;|
GRIND-USE-ORIGINAL-READTABLE REMSEMI PROGRAMSPACE
COMSPACE GAP ↑R ↑W ↑T ↑V ↑S ↑Q)
(SPECIAL %TOP-EDIT-EXP %EDIT-PRINDEPTH %EDITPROPERTIES ←
%EDITFUNCTIONS *%X %/#UNDOLIST %/#UNDOFLAG %LAST-PATTERN %REPLACE-FLAG
%EDIT-PRINLENGTH %/#CE %/#CHAIN ?%PAT ?%X ?%Y ?%N %/#CONTINUE-STACK
%COMMENTS? %EDITREADTABLE %STANDARDREADTABLE %LAST-CONTINUE-STACK
%LAST-FIND-PATTERN %MARKCHAIN %MARKCHAINLENGTH %/#RETAIN %LAST-SAVE-FILE
%COMMAND %INITIALIZE-EDITOR? %UNDOQLENGTH ?CE %/#WINDOW-STACK
[IFN SAIL %%NEXT-SYM%%] ⊗ %/#EVERYTIME %/#DRAFTP
%/#WINDOW-SIZE))
(EVAL-WHEN (LOAD EVAL COMPILE)
(COND ((STATUS FEATURES NEWIO)
(DEFUN VERSION MACRO (X)
(list 'quote (caddr (namelist infile)))))
(T (DEFUN VERSION MACRO (X)(LIST 'QUOTE (CADR (STATUS UREAD)))))))
(DEFUN %EDIT-LOAD-MSG NIL
(OR (STATUS FEATURE NOLDMSG)
((LAMBDA(↑R)
(TERPRI)
(PRINC '|;loading EDIT.|)
(PRINC (VERSION))
(PRINC '| |))
NIL)))
(%EDIT-LOAD-MSG)
;; some macros used in this file
[IFE SAIL (DEFUN MACRO BEEP (X) '(TYO 7))]
(DEFUN PUSH MACRO (X)
(LIST 'SETQ
(CADDR X)
(LIST 'CONS (CADR X) (CADDR X))))
(DEFUN COPY MACRO (X) (LIST 'SUBST NIL NIL (CADR X)))
(DEFUN %IOG% MACRO (X)
;; simulates the losing IOG function.
;; actually simulates Finin's losing IOG simulator
(PROG (↑CHAR LIST-OF-TS TEMP)
(DO ((CH (EXPLODE (CADR X)) (CDR CH)))
((NULL CH))
(SETQ TEMP (ASSQ (CAR CH)
'((V W NIL) (W W T) (R R T) (T R NIL) (Q Q T) (S Q NIL))))
(OR TEMP (ERROR '|Nasty losing IOG error| (CAR CH)))
(PUSH (IMPLODE (LIST '↑ (CADR TEMP))) ↑CHAR)
(PUSH (CADDR TEMP) LIST-OF-TS))
(RETURN (CONS (CONS 'LAMBDA (CONS ↑CHAR (CDDR X)))
LIST-OF-TS))))
[IFN NEWIO
(defun %ufile fexpr (file)
(cond ((status features newio)
((lambda (filename)
(cond ((probef filename)
(deletef filename))))
(funcall 'namelist file))))
(apply 'ufile file))]
[IFE NEWIO
(defun %ufile fexpr (file)(apply 'ufile file))]
(DEFUN IMPCOND MACRO (X)
;;for different implementations.
(RPLACA X 'COND)
(MAPC '(LAMBDA (CLAUSE) (RPLACA CLAUSE
(LIST 'STATUS
'FEATURE
(CAR CLAUSE))))
(CDR X))
X)
(DEFUN COMMAND= MACRO (X)
(COND ((AND (CDDR X) (ATOM (CADR X)))
(LIST 'MEMQ
'%COMMAND
(LIST 'QUOTE (CDR X))))
((ATOM (CADR X))
(LIST 'EQ
(LIST 'QUOTE (CADR X))
'%COMMAND))
((OR (NOT (ATOM (CAADR X)))
(MEMQ (CAR (EXPLODE (CAADR X)))
'(? *)))
(LIST '%MATCH
(LIST 'QUOTE (CADR X))
'%COMMAND))
(T (LIST 'AND
(LIST 'EQ
'(CAR %COMMAND)
(LIST 'QUOTE (CAADR X)))
(LIST '%MATCH
(LIST 'QUOTE (CDADR X))
'(CDR %COMMAND))))))
;;*page
;;*(programspace 45.)
;;; initial values for all global variables.
(SETQ %/#CE NIL ; the current expression
%TOP-EDIT-EXP NIL ; the top-level expression being edited.
%/#CHAIN NIL ; tells where in %top-edit-exp the %/#ce is
%/#UNDOFLAG NIL ; switch for the "undo" feature
%/#UNDOLIST NIL ; things to undo, if requested
%UNDOQLENGTH 6. ; %UNDOLIST is a queue, and this is it's length
%/#WINDOW-SIZE 1 ; size of the window
%EDITREADTABLE (GET 'READTABLE
'ARRAY)
%STANDARDREADTABLE %EDITREADTABLE
%EDITFUNCTIONS NIL ; extra function defining forms for %refile.
%EDITPROPERTIES NIL ; extra function properties recognized by editor
%COMMENTS? NIL ; semi-colon comment flag, T ==> PRESERVE COMMENTS.
%LAST-FIND-PATTERN NIL ; default pattern to search for
%LAST-PATTERN NIL ; default pattern to match against
%LAST-CONTINUE-STACK NIL ; stack to continue match
%LAST-SAVE-FILE NIL ; last file SAVE'd to
%/#RETAIN NIL ; says to retain continue-stack
%EDIT-PRINDEPTH 2. ; editor's own prindepth
%EDIT-PRINLENGTH 5. ; editor's own prinlevel
%MARKCHAIN NIL ; tells where the "mark" is in %top-edit-exp
%MARKCHAINLENGTH 0. ; length of %markchain
%COMMAND NIL ; (special because of %toundo: )
TO-REFILE NIL ; .
REFILE-ALL NIL ; .
%/#DRAFTP T ; saves DRAFT property
?%PAT NIL ; five random globals
?%X NIL
?%N NIL
?%Y NIL
*%X NIL
?CE NIL ; CE pattern variable
⊗ NIL
[IFN SAIL %%NEXT-SYM%% 0]
%/#EVERYTIME NIL ;evaled each time through the loop
%INITIALIZE-EDITOR? T) ; to load init file
;; this is to circumvent a bug in GRINDEF/GRIND
(SETQ REMSEMI NIL)
;;*(PROGRAMSPACE 70.)
;;*page
(DEFUN EDIT FEXPR (X)
;; THIS IS A HACK WHICH SHOULD GO AWAY WITH NEW I/O
(AND %INITIALIZE-EDITOR? (%LOAD-EDIT-INIT-FILE))
(COND ((NOT (EQ (CAR X) (%GETNAME %TOP-EDIT-EXP)))
(AND %TOP-EDIT-EXP
((LAMBDA (Y)
(AND Y (PUTPROP Y
%TOP-EDIT-EXP 'DRAFT)))
(%GETNAME %TOP-EDIT-EXP)))))
(AND X (SETQ X (APPLY '%DATA-INIT X)))
(EDIT1 NIL)
(OR X T))
(DEFUN RE-EDIT FEXPR (X)
(REMPROP (CAR X) 'DRAFT)
(AND %INITIALIZE-EDITOR? (%LOAD-EDIT-INIT-FILE))
(COND ((NULL X) (SETQ X (NCONS (%GETNAME %TOP-EDIT-EXP)))))
(SETQ X (APPLY '%DATA-INIT X))
(EDIT1 NIL)
(OR X T))
(DEFUN EDIT1 (FORM)
(AND %INITIALIZE-EDITOR? (%LOAD-EDIT-INIT-FILE))
(SETQ GRIND-USE-ORIGINAL-READTABLE NIL)
(SSTATUS TOPLEVEL '(%EDITOR-TOPLEVEL))
(COND ((MEMBER '(SETQ * '*) ERRLIST))
(T (PUSH '(SETQ * '*) ERRLIST)))
(COMMENT (SSTATUS BREAKLEVEL '(%EDITOR-TOPLEVEL)))
(AND %TOP-EDIT-EXP (PUTPROP (%GETNAME %TOP-EDIT-EXP)
%TOP-EDIT-EXP 'DRAFT))
(AND FORM (SETQ %/#CHAIN NIL %/#CE FORM %TOP-EDIT-EXP FORM) T))
;;; Foo! A hack so that lusers can say "(Edit2 a)" to get
;;; (prog2 (setq a (quote <value of a>)) t) and "(edit2 (get foo bar))"
;;; to get (defprop foo <property of foo with indicator bar> bar) as
;;; the editable object
(DEFUN EDITV FEXPR (X)
(APPLY 'EDIT2 X))
(DEFUN EDITP FEXPR (X)
(APPLY 'EDIT2 (NCONS (LIST 'GET (CAR X)(CADR X)))))
(DEFUN EDIT2 FEXPR (FORM)
(AND %TOP-EDIT-EXP (PUTPROP (%GETNAME %TOP-EDIT-EXP)
%TOP-EDIT-EXP 'DRAFT))
(COND ((ATOM (CAR FORM))
(SETQ ?%X (CAR FORM) ?%Y (SYMEVAL ?%X))
(EDIT1 `(PROG2 (SETQ ,?%X (QUOTE ,?%Y)) T)))
((%MATCH '(GET ?%X ?%N) (CAR FORM))
(SETQ ?%Y (GET ?%X ?%N))
(EDIT1 (%INSTANTIATE '(DEFPROP ?%X ?%Y ?%N)))))
T)
(DEFUN BEDIT NIL (SSTATUS BREAKLEVEL '(%EDITOR-TOPLEVEL)))
(DEFUN BEXIT NIL (SSTATUS BREAKLEVEL NIL))
(MACRODEF FAKEREAD () (COND (READ (FUNCALL READ))
(T (READ))))
(DEFUN %EDITOR-TOPLEVEL NIL
;; prints NIL? if an editor command fails and "←" if it
;;succeedes. if we are reading from the disk, don't use
;;%editreadtable (in case we are in "comment" mode).
(OR * (PROGN (TERPRI) (PRINC '|nil?|)))
(PRINT '←)
(PROG2 NIL
(*CATCH
'%editor-toplevel
(%EVALUATE ((LAMBDA (READTABLE) (FAKEREAD))
(COND (↑Q %STANDARDREADTABLE)
(T %EDITREADTABLE)))))
(AND %/#EVERYTIME (EVAL %/#EVERYTIME))))
(DEFUN %EDMACRO NIL (LIST '%EVALUATE (READ)))
(DEFUN %EVALUATE (%COMMAND)
(PROG2
(SETQ ?CE %/#CE - %COMMAND )
(SETQ *
(COND ((OR (NUMBERP %COMMAND) (AND (NOT (ATOM %COMMAND))
(NUMBERP (CAR %COMMAND))))
(%EVAL-NUMBER %COMMAND))
((AND (ATOM %COMMAND)
(GET %COMMAND 'ATOMIC-EDITCOMMAND))
(%EVAL-ATOM %COMMAND))
((GET (CAR %COMMAND) 'LIST-EDITCOMMAND)
(%EVAL-LIST %COMMAND))
(T (PRINT (SETQ ⊗ (EVAL (COND ((AND %COMMENTS? ↑Q)
(%FLUSHCOMMENTS %COMMAND))
(T %COMMAND)))))
T)))
(SETQ + %COMMAND)))
(DEFUN %EVAL-NUMBER (%COMMAND)
(COND ((NUMBERP %COMMAND)
(AND (%DESCEND %COMMAND) (%TOUNDO: '↑)))
((COMMAND= (?%N))
(AND (< ?%N 0.) (SETQ ?%N (+ ?%N (%LENGTH %/#CE) 1.)))
(AND (LESSP 0. ?%N (1+ (%LENGTH %/#CE)))
(%TOUNDO: (LIST 'A
(1- ?%N)
(%CARN %/#CE ?%N)))
(%DELETE ?%N)))
((COMMAND= (?%N *%X))
(AND (< ?%N 0.) (SETQ ?%N (+ ?%N (%LENGTH %/#CE) 1.)))
(AND (LESSP 0. ?%N (1+ (%LENGTH %/#CE)))
(%TOUNDO: (LIST ?%N (%CARN %/#CE ?%N))
(LIST '%DELETER
(1+ ?%N)
(1- (%LENGTH *%X))))
(%REPLACE *%X ?%N)))))
;;*page
;;; match attempts to match the last pattern against the CE
;;; rematch attempts to obtain the next possible match between
;;; the last pattern and the CE
(DEFUN %EVAL-ATOM (%COMMAND)
(COND ((COMMAND= HELP) (%EDIT-HELP))
((COMMAND= UNDO)
(COND (%/#UNDOLIST ((LAMBDA (↑W %/#UNDOFLAG
THINGS-TO-UNDO)
(MAPC (FUNCTION %EVALUATE)
THINGS-TO-UNDO))
T
NIL
(%POP)))
(T (%P '|empty undolist?|))))
((COMMAND= P) ; printing commands
((LAMBDA (PRINLEVEL PRINLENGTH) (PRINT %/#CE))
%EDIT-PRINDEPTH
%EDIT-PRINLENGTH)
T)
((COMMAND= W)(TERPRI)(%WINDOW %/#WINDOW-SIZE))
((COMMAND= PS)
(%SPRINT (%STRUCTURE %/#CE %EDIT-PRINDEPTH)))
((COMMAND= PP) (%SPRINT %/#CE))
((COMMAND= ↑) ; moving commands
(AND %/#CHAIN (%TOUNDO: (CDAR %/#CHAIN)) (%ASCEND)))
((COMMAND= TOP)
(%TOUNDO: (LIST '%RESTORE-STATE
(LIST 'QUOTE %/#CHAIN)))
(SETQ %/#CHAIN NIL %/#CE %TOP-EDIT-EXP)
T)
[IFN SAIL
((COMMAND= L) (INITED)(COND ((ADDED (LIST 'CR %/#CE) T) (LOADED) T)) )]
[IFN SAIL
((COMMAND= LS) (SETQ %%NEXT-SYM%% 0)(INITED)
(COND(
(ADDED (LIST 'PR (%STRUCTURE-LS %/#CE
%EDIT-PRINDEPTH)) T)
(LOADED) T)) )]
((COMMAND= NX) (AND (%NEXT) (%TOUNDO: 'BK)))
((COMMAND= BK) (AND (%BEFORE) (%TOUNDO: 'NX)))
((COMMAND= RI) (AND (%MRPI) (%TOUNDO: 'RO))) ; reforming commands
((COMMAND= RO) (AND (%MRPO) (%TOUNDO: 'RI)))
((COMMAND= LI) (AND (%MLPI) (%TOUNDO: 'LO)))
((COMMAND= LO) (AND (%MLPO) (%TOUNDO: 'LI)))
((COMMAND= DELETE)
(COND (%/#CHAIN (%TOUNDO: (LIST 'A
(1- (CDAR %/#CHAIN))
(NCONS %/#CE))
(CDAR %/#CHAIN)))
((%TOUNDO: (LIST 'CR
(NCONS (SUBST NIL NIL %/#CE))))))
(OR (%CDELETE) (%DATA-INIT) T))
((COMMAND= MARK) (%TOUNDO: (%SAVEMARK)) (%MARK)) ; marking commands
((COMMAND= UNMARK)
(%TOUNDO: (%SAVEMARK))
(SETQ %MARKCHAIN NIL %MARKCHAINLENGTH 0.))
((COMMAND= JUMP)
(%TOUNDO: (LIST '%RESTORE-STATE
(LIST 'QUOTE %/#CHAIN)))
(OR (%JUMP) (%POP))
T)
((COMMAND= F) ; searching commands
(%EVAL-LIST (LIST 'F %LAST-FIND-PATTERN)))
((COMMAND= BF)
(%EVAL-LIST (LIST 'BF %LAST-FIND-PATTERN)))
((COMMAND= EXIT) ; random atomic commands
(TERPRI)(PRINC '|;Bye|)(TERPRI)
(SSTATUS TOPLEVEL NIL)
(DELETE '(SETQ * '*) ERRLIST 1.))
((COMMAND= OK)
(%TOUNDO: (%UNDOKSET))
((LAMBDA (NAME)
(AND (STATUS FEATURES TRACE)
(GETL 'TRACE
'(FEXPR FSUBR LEXPR LSUBR))
(MEMQ NAME (TRACE))
(PROGN
(APPLY 'UNTRACE (NCONS NAME))
(%P NAME '|traced, will untrace and define...|))))
(%GETNAME %/#CE))
(PRINT (EVAL (%FLUSHCOMMENTS (COPY %TOP-EDIT-EXP))))
(AND (EQ (CAR %TOP-EDIT-EXP) 'DEFUN)
%/#DRAFTP
(PUTPROP (CADR %TOP-EDIT-EXP)
(COPY %TOP-EDIT-EXP)
'DRAFT))
T)
((COMMAND= MATCH)(PROG2 NIL ((LAMBDA(%/#RETAIN)
(%MATCH %LAST-PATTERN %/#CE)) T)
(SETQ %LAST-CONTINUE-STACK %/#CONTINUE-STACK)))
((COMMAND= REMATCH)(PROG2 NIL ((LAMBDA(%/#RETAIN)
(%CONTINUE-MATCH %LAST-PATTERN %/#CE
%LAST-CONTINUE-STACK)) T)
(SETQ %LAST-CONTINUE-STACK %/#CONTINUE-STACK)))
((COMMAND= SAVE)
(OR %LAST-SAVE-FILE
(SETQ %LAST-SAVE-FILE
(%READ-FILE-NAME
'|<file-specification>: |)))
(PRINT (%WRITEF %TOP-EDIT-EXP %LAST-SAVE-FILE)))
((COMMAND= REMEMBER)
(SETQ ?%X (%GETNAME %TOP-EDIT-EXP))
(%TOUNDO: (LIST 'DEFPROP
?%X
(GET ?%X 'DRAFT)
'DRAFT))
(PUTPROP ?%X %TOP-EDIT-EXP 'DRAFT))
(T (PRINT (EVAL (GET %COMMAND 'ATOMIC-EDITCOMMAND))) T)))
;;*page
;;; (match ?pat *vars) attempts to match ?pat against CE retaining the
;;; ?- and *-variables in *var
;;; (rematch *vars) attempts the next possible match retaining *vars
(DEFUN %EVAL-LIST (%COMMAND)
(COND
((COMMAND= (COMMENT ?%X)) ; EDITOR VARIABLE SETTING COMMANDS
;; LOAD GRIND IF NOT ALREADY IN (TO HANDLE SEMI-COLON
;;COMMENTS).
(AND ?%X
(STATUS NOFEATURE GRIND)
((LAMBDA (ID) [IFN SAIL (FASLOAD GRIND FAS DSK (MAC LSP))]
[IFN ((NOT SAIL) DEC10) (FASLOAD GRIND FAS SYS (1 2))]
[IFN ITS (FASLOAD GRIND FASL COM)]
(APPLY 'CRUNIT ID))
(CRUNIT))) ; MODIFY FOR ITS
(%TOUNDO: (LIST 'SETQ
'%EDITREADTABLE
%EDITREADTABLE
'%COMMENTS?
%COMMENTS?))
(SETQ %EDITREADTABLE (COND (?%X GRINDREADTABLE)
(%STANDARDREADTABLE))
%COMMENTS? ?%X)
T)
((COMMAND= (UNDO T)) (SETQ %/#UNDOFLAG T))
((COMMAND= (UNDO NIL)) (SETQ %/#UNDOFLAG NIL %/#UNDOLIST NIL)
T)
((COMMAND= (UNDO ($R ?%N %POS)))
(SETQ %/#UNDOFLAG T)
((LAMBDA (?%X) (SETQ %UNDOQLENGTH ?%N)
(%TOUNDO: (LIST 'UNDO ?%X)))
%UNDOQLENGTH)
T)
((COMMAND= (WINDOW ($R ?%N %POS)))
(%TOUNDO: (LIST 'WINDOW %/#WINDOW-SIZE))
(SETQ %/#WINDOW-SIZE ?%N))
((COMMAND= (PL ($R ?%N %POS)))
(%TOUNDO: (LIST 'PL %EDIT-PRINLENGTH))
(SETQ %EDIT-PRINLENGTH ?%N))
((COMMAND= (PD ($R ?%N %POS)))
(%TOUNDO: (LIST 'PD %EDIT-PRINDEPTH))
(SETQ %EDIT-PRINDEPTH ?%N))
((COMMAND= (AI *%X)) ; INSERTION COMMANDS
(SETQ %COMMAND (%LENGTH *%X))
(AND (%ACINSERT *%X)
(%TOUNDO: (LIST '%UNDOA -1. (1+ %COMMAND)))))
((COMMAND= (BI *%X))
(SETQ %COMMAND (%LENGTH *%X))
(AND (%BCINSERT *%X)
(%TOUNDO: (LIST '%UNDOA 1. (1+ %COMMAND)))))
((COMMAND= (PAI *%X))
(SETQ *%X (%INSTANTIATE *%X) %COMMAND (%LENGTH *%X))
(AND (%ACINSERT *%X)
(%TOUNDO: (LIST '%UNDOA -1. (1+ %COMMAND)))))
((COMMAND= (DRAFT ?%X))
(%TOUNDO: (LIST 'SETQ '%/#DRAFTP %/#DRAFTP))
(SETQ %/#DRAFTP ?%X))
((COMMAND= (PBI *%X))
(SETQ *%X (%INSTANTIATE *%X) %COMMAND (%LENGTH *%X))
(AND (%BCINSERT *%X)
(%TOUNDO: (LIST '%UNDOA 1. (1+ %COMMAND)))))
((COMMAND= (B ($R ?%N NUMBERP) *%X))
(SETQ %COMMAND (%LENGTH *%X))
(AND (%BINSERT *%X ?%N)
(%TOUNDO: (LIST '%DELETER
(COND ((< ?%N 0.) (- ?%N %COMMAND))
(T ?%N))
%COMMAND))))
((COMMAND= (PB ($R ?%N NUMBERP) *%X))
(SETQ *%X (%INSTANTIATE *%X) %COMMAND (%LENGTH *%X))
(AND (%BINSERT *%X ?%N)
(%TOUNDO: (LIST '%DELETER
(COND ((< ?%N 0.) (- ?%N %COMMAND))
(T ?%N))
%COMMAND))))
((COMMAND= (A ($R ?%N NUMBERP) *%X))
(SETQ %COMMAND (%LENGTH *%X))
(AND (%AINSERT *%X ?%N)
(%TOUNDO: (LIST '%DELETER
(COND ((< ?%N 0.) ?%N) (T (1+ ?%N)))
%COMMAND))))
((COMMAND= (PA ($R ?%N NUMBERP) *%X))
(SETQ *%X (%INSTANTIATE *%X) %COMMAND (%LENGTH *%X))
(AND (%AINSERT *%X
(COND ((< ?%N 0.) (+ ?%N 1. (%LENGTH %/#CE)))
(?%N)))
(%TOUNDO: (LIST '%DELETER
(COND ((< ?%N 0.) ?%N) (T (1+ ?%N)))
(+ ?%N %COMMAND)))))
((COMMAND= (R ?%X ?%Y)) ; REPLACEMENT COMMANDS
(%TOUNDO: (LIST 'CR (SUBST NIL NIL %/#CE)))
(COND ((ATOM %/#CE)
(AND (SETQ ?%X (%STRINGSUB (EXPLODE ?%X)
(EXPLODE ?%Y)
%/#CE))
(%CREPLACE (LIST ?%X))))
(T ((LAMBDA(%REPLACE-FLAG)
(%LSUBSTITUTE ?%X ?%Y %/#CE)
%REPLACE-FLAG)
NIL))))
((COMMAND= (TR ?%X ?%Y)) ; REPLACEMENT COMMANDS
(%TOUNDO: (LIST 'CR (SUBST NIL NIL %/#CE)))
(COND ((ATOM %/#CE)
(AND (SETQ ?%X (%STRINGSUB (EXPLODE ?%X)
(EXPLODE ?%Y)
%/#CE))
(%CREPLACE (LIST ?%X))))
(T ((LAMBDA(%REPLACE-FLAG)
(%SUBSTITUTE ?%X ?%Y %/#CE)
%REPLACE-FLAG)
NIL))))
((COMMAND= (R ?%X))
(COND ((AND (ATOM %/#CE) (EQUAL ?%X %/#CE))
(%EVAL-ATOM 'DELETE))
((ATOM %/#CE)
(%TOUNDO: (LIST 'CR (SUBST NIL NIL %/#CE)))
(AND (SETQ ?%X (%STRINGSUB (EXPLODE ?%X) NIL %/#CE))
(%CREPLACE (LIST ?%X))))))
((COMMAND= (PRA ?%X ?%Y))
(%TOUNDO: (LIST 'CR (SUBST NIL NIL %/#CE)))
((LAMBDA(%REPLACE-FLAG)
(OR
(ERRSET (%LSUBSTITUTE ?%X (%INSTANTIATE ?%Y) %/#CE))
(%POP))
%REPLACE-FLAG)
NIL))
((COMMAND= (TPRA ?%X ?%Y))
(%TOUNDO: (LIST 'CR (SUBST NIL NIL %/#CE)))
((LAMBDA(%REPLACE-FLAG)
(OR
(ERRSET (%SUBSTITUTE ?%X (%INSTANTIATE ?%Y) %/#CE))
(%POP))
%REPLACE-FLAG)
NIL))
((COMMAND= (PR *%X))
(SETQ *%X (%INSTANTIATE *%X))
(COND ((OR (= (%LENGTH *%X) 1.) (NULL %/#CHAIN))
(%TOUNDO: (LIST 'CR (SUBST NIL NIL %/#CE))))
(T (%TOUNDO: (LIST 'CR (SUBST NIL NIL %/#CE))
'(%NEXT)
(LIST '%UNDOA -1. (%LENGTH *%X)))))
(OR (ERRSET (%CREPLACE *%X)) (%POP) T))
((COMMAND= (CR *%X))
(COND ((OR (= (%LENGTH *%X) 1.) (NULL %/#CHAIN))
(%TOUNDO: (LIST 'CR (SUBST NIL NIL %/#CE))))
(T (%TOUNDO: (LIST 'CR (SUBST NIL NIL %/#CE))
'(%NEXT)
(LIST '%UNDOA -1. (%LENGTH *%X)))))
(%CREPLACE *%X))
((COMMAND= (F ?%PAT ?%X)) ; SEARCHING COMMANDS
(%TOUNDO: (LIST '%RESTORE-STATE
(LIST 'QUOTE %/#CHAIN)))
(OR (%FIND ?%PAT 1. ?%X) (PROG2 (%POP) NIL)))
((COMMAND= (F ?%PAT))
(%TOUNDO: (LIST '%RESTORE-STATE
(LIST 'QUOTE %/#CHAIN)))
(OR (%FIND ?%PAT 1. 1.) (PROG2 (%POP) NIL)))
((COMMAND= (BF ?%PAT ?%X))
(%TOUNDO: (LIST '%RESTORE-STATE
(LIST 'QUOTE %/#CHAIN)))
(OR (%FIND ?%PAT -1. ?%X) (PROG2 (%POP) NIL)))
((COMMAND= (BF ?%PAT))
(%TOUNDO: (LIST '%RESTORE-STATE
(LIST 'QUOTE %/#CHAIN)))
(OR (%FIND ?%PAT -1. 1.) (PROG2 (%POP) NIL)))
((COMMAND= (MATCH ?%PAT)) (PROG2 (SETQ %LAST-PATTERN ?%PAT)
((LAMBDA(%/#RETAIN)
(%MATCH ?%PAT %/#CE)) T)
(SETQ %LAST-CONTINUE-STACK %/#CONTINUE-STACK))) ; RANDOM COMMANDS
((COMMAND= (MATCH ?%PAT *%X))(PROG2 (SETQ %LAST-PATTERN ?%PAT)
((LAMBDA(%/#RETAIN)
(%MATCH ?%PAT %/#CE *%X)) T)
(SETQ %LAST-CONTINUE-STACK
%/#CONTINUE-STACK)))
((COMMAND= (REMATCH *%X))(PROG2 NIL ((LAMBDA(%/#RETAIN)
(%CONTINUE-MATCH %LAST-PATTERN %/#CE
%LAST-CONTINUE-STACK *%X)) T)
(SETQ %LAST-CONTINUE-STACK %/#CONTINUE-STACK)))
((COMMAND= (SAVE *%X))
(SETQ %LAST-SAVE-FILE *%X)
(PRINT (%WRITEF %TOP-EDIT-EXP *%X)))
((COMMAND= (REFILE *%X))
; (TERPRI)
; (PRINC '|Sorry, refile doesn't work pending fixes to GRIND|)
; (TERPRI)
(PRINT (%REFILE (CAR *%X) (CADR *%X) (CADDR *%X)))
)))
;;*page
;;;;;;;;;;;;;;;; functions to move around the tree ;;;;;;;;;;
(DEFUN %DESCEND (N)
;; moves the CE to the nth element of the current CE. if
;; n < 0 then counts from end of the CE.
(DECLARE (FIXNUM N))
(AND (< N 0.) (SETQ N (+ N 1. (%LENGTH %/#CE))))
(AND (LESSP 0. N (1+ (%LENGTH %/#CE)))
(PUSH (CONS %/#CE N) %/#CHAIN)
(OR (SETQ %/#CE (%CARN %/#CE N)) T)))
(DEFUN %ASCEND NIL
;; makes the CE the fater of the current CE. returns:
;; The son-number ascended from or NIL if no father.
(AND %/#CHAIN
(PROG2 NIL
(CDAR %/#CHAIN)
(SETQ %/#CE (CAAR %/#CHAIN) %/#CHAIN (CDR %/#CHAIN)))))
(DEFUN %NEXT NIL
;; makes the CE the "right brother" of the current CE.
;;returns NIL if current CE is last in a list.
(AND %/#CHAIN
(< (CDAR %/#CHAIN) (%LENGTH (CAAR %/#CHAIN)))
(%DESCEND (1+ (%ASCEND)))))
(DEFUN %BEFORE NIL
;; makes the ce the "left brother" of the current ce.
;; Returns nil if current ce is first in the list.
(AND %/#CHAIN (> (CDAR %/#CHAIN) 1.) (%DESCEND (1- (%ASCEND)))))
; These functions create and print the "window" about the %/#ce.
(DEFUN %WINDOW (N)
(DECLARE (FIXNUM N))
(PROG (%/#WINDOW-STACK)
(%WINDOW-FORWARD %/#CE %/#CHAIN N)
(SETQ %/#WINDOW-STACK (NREVERSE %/#WINDOW-STACK))
(PUSH %/#CE %/#WINDOW-STACK)
(%WINDOW-BACK %/#CE %/#CHAIN N)
((LAMBDA (PRINLEVEL PRINLENGTH)
(MAP (FUNCTION (LAMBDA (X) (PRINC (CAR X))
(COND ((OR (EQUAL (CAR X) '|(|)
(EQUAL (CADR X) '|)|)))
(T (PRINC '| |)))))
%/#WINDOW-STACK))
%EDIT-PRINLENGTH
%EDIT-PRINDEPTH)
(RETURN T)))
(DEFUN %WINDOW-BACK (%/#CE %/#CHAIN N)
(DECLARE (FIXNUM I N))
(DO ((I 1. (1+ I)))
((< N I) (COND ((%BEFORE) (PUSH '|...| %/#WINDOW-STACK))
((%ASCEND) (PUSH '|(| %/#WINDOW-STACK))))
(COND ((%BEFORE) (PUSH %/#CE %/#WINDOW-STACK))
((%ASCEND) (PUSH '|(| %/#WINDOW-STACK))
(T (RETURN NIL)))))
(DEFUN %WINDOW-FORWARD (%/#CE %/#CHAIN N)
(DECLARE (FIXNUM I N))
(DO ((I 1. (1+ I)))
((< N I) (COND ((%NEXT) (PUSH '|...| %/#WINDOW-STACK))
((%ASCEND)
(PUSH '|)| %/#WINDOW-STACK))))
(COND ((%NEXT) (PUSH %/#CE %/#WINDOW-STACK))
((%ASCEND) (PUSH '|)| %/#WINDOW-STACK))
(T (RETURN NIL)))))
;;*page
;;;;;;;;;; functions for inserting stuff ;;;;;;;;;;
(DEFUN %AINSERT (L N)
;; insert l after the ce's nth element. returns nil if "n
;; " can't refer to an element of the ce.
(DECLARE (FIXNUM N))
(AND (MINUSP N) (SETQ N (+ N (%LENGTH %/#CE) 1.)))
(AND (LESSP -1. N (1+ (%LENGTH %/#CE)))
(%REMARK N (%LENGTH L))
(COND ((NOT (ZEROP N))
(RPLACD (%CDRN %/#CE (1- N))
(NCONC L (%CDRN %/#CE N))))
((NULL %/#CHAIN)
(SETQ %/#CE (NCONC L %/#CE) %TOP-EDIT-EXP %/#CE))
(T (SETQ N (%ASCEND))
(RPLACA (%CDRN %/#CE (1- N))
(NCONC L (%CARN %/#CE N)))
(%DESCEND N)))))
(DEFUN %BINSERT (L N)
;; splices in L before the ce's nth element.
(%AINSERT L (1- N)))
(DEFUN %ACINSERT (L)
;; splices in L after the current expression.
(PROG (N)
(COND ((SETQ N (%ASCEND))
(%AINSERT L N)
(%DESCEND (1+ N))
(RETURN T)))))
(DEFUN %BCINSERT (L)
;; splices in L before the current expression.
(PROG (N)
(COND ((SETQ N (%ASCEND))
(%BINSERT L N)
(%DESCEND N)
(RETURN T)))))
;;*page
;;;;;;;;;; deleting functions ;;;;;;;;;;
(DEFUN %DELETER (N M)
;; deletes M elements of the ce, begining with the Nth.
(DECLARE (FIXNUM N M))
(DO I 1. (1+ I) (> I M) (%DELETE N)))
(DEFUN %DELETE (N)
;; deletes the nth element of the ce.
(DECLARE (FIXNUM N))
(COND ((MINUSP N) (SETQ N (+ N (%LENGTH %/#CE) 1.))))
(PROG (M)
(COND ((NOT (LESSP 0. N (1+ (%LENGTH %/#CE))))
(RETURN NIL))
((> N 1.)
(RPLACD (%CDRN %/#CE (- N 2.)) (%CDRN %/#CE N)))
((NULL %/#CHAIN)
(SETQ %/#CE (CDR %/#CE) %TOP-EDIT-EXP %/#CE))
((SETQ M (%ASCEND))
(RPLACA (%CDRN %/#CE (1- M)) (CDR (%CARN %/#CE M)))
(%DESCEND M)))
(%REMARK N -1.)
(RETURN T)))
(DEFUN %CDELETE NIL
;; delete the current expression. returns nil if the ce
;; is the top-level expression.
(AND %/#CHAIN (%DELETE (%ASCEND))))
;;*page
;;;;;;;;; undoing functions
(DEFUN %RESTORE-STATE (NEWCHAIN)
;; undoer for top, jump, and searching commands.
(SETQ %/#CHAIN NEWCHAIN
%TOP-EDIT-EXP (CAAR (LAST NEWCHAIN))
%/#CE (COND (NEWCHAIN (%CARN (CAAR NEWCHAIN)
(CDAR NEWCHAIN)))
(%TOP-EDIT-EXP))))
(DEFUN %UNDOA (N M)
;; random undoer. deletes the nth thru mth elements of the
;; ce. (DECLARE (FIXNUM TEMP N M))
(PROG (TEMP)
(SETQ TEMP (%ASCEND))
(%DELETER TEMP (1- M))
(%DESCEND (+ N TEMP))
(RETURN T)))
(DEFUN %UNDOKSET NIL
;; undoer for 'ok'. restores draft and then evals draft.
(COND ((MEMQ (CAR %TOP-EDIT-EXP) '(DEFUN DEFPROP PUTPROP DEFINE))
(PROG (NAME)
(SETQ NAME (%GETNAME %TOP-EDIT-EXP))
(RETURN (LIST 'EVAL
(LIST 'PUTPROP
(LIST 'QUOTE NAME)
(LIST 'QUOTE
(GET NAME 'DRAFT))
''DRAFT))))) ))
(DEFUN %TOUNDO: FEXPR (FORMS)
;; pushes forms onto the undolist.
(DECLARE (FIXNUM J))
(AND %/#UNDOFLAG
(PUSH (MAPCAR (FUNCTION EVAL) FORMS) %/#UNDOLIST)
(DO ((I %/#UNDOLIST (CDR I)) (J 1. (1+ J)))
((NULL I))
(COND ((= J %UNDOQLENGTH)
(RPLACD I NIL)
(RETURN T)))))
T)
(DEFUN %POP NIL
;; pops the undolist.
(AND %/#UNDOFLAG
%/#UNDOLIST
(PROG2 NIL
(CAR %/#UNDOLIST)
(SETQ %/#UNDOLIST (CDR %/#UNDOLIST)))))
(DEFUN %SAVEMARK NIL
(LIST 'SETQ
'%MARKCHAIN
(LIST 'QUOTE %MARKCHAIN)
'%MARKCHAINLENGTH
%MARKCHAINLENGTH))
;;*page
;;;;;;;;;; functions to initialize the
;;;;;;;;;; editor to a new function.
(DEFUN %DATA-INIT FEXPR (ARGS)
;; typical args: (data-init <function> <file-specs> returns complete specifications.
(PROG (SPECS)
(AND (SETQ SPECS ARGS) (GO START))
L2 (%P '|(<function name> <file specifications>) :|)
[IFN SAIL (INITED)(ADDED (COND ((= (LENGTH SPECS) 1) (CAR SPECS))
(T SPECS)) T)(LOADED)]
(SETQ SPECS (READ))
(AND (ATOM SPECS) (SETQ SPECS (LIST SPECS)))
START(COND ((EQUAL SPECS '(NEW))
(SETQ %TOP-EDIT-EXP NIL))
((EQUAL SPECS '(UNDO)) (RETURN T))
((NULL (CDR SPECS))
(OR (SETQ %TOP-EDIT-EXP (%GETDEF (CAR SPECS)))
(GO L2)))
((> (%LENGTH SPECS) 1.)
(OR (SETQ %TOP-EDIT-EXP (%READF (CAR SPECS)
(CDR SPECS)))
(GO L2))))
(SETQ %/#CE %TOP-EDIT-EXP %/#CHAIN NIL)
(RETURN SPECS)))
(DEFUN %GETNAME (EXP)
;; assumes exp is a function definition. returns its name
(AND (> (%LENGTH EXP) 2.)
(MEMQ (CAR EXP) '(DEFUN DEFINE DEFPROP PUTPROP))
(COND ((MEMQ (CADR EXP) '(EXPR FEXPR LEXPR MACRO))
(CADDR EXP))
(T (CADR EXP)))))
(DEFUN %GETDEF (NAME)
;; gets the definition of the function NAME.
(PROG (F G H TYPE TRACED?)
(COND ((SETQ F (GET NAME 'DRAFT)) (RETURN F))) ;(GET ...) WAS (%GETDEF1 ...)
(SETQ F (APPEND '(EXPR FEXPR LEXPR MACRO)
%EDITPROPERTIES)
H F
TRACED? (AND (STATUS FEATURES TRACE)
(GETL 'TRACE
'(FEXPR FSUBR LEXPR LSUBR))
(MEMQ NAME (TRACE))))
A (SETQ TYPE (CAR F) F (CDR F))
(SETQ G (COND (TRACED? (GET (CDR (MEMQ TYPE (PLIST NAME)))
TYPE))
((GET NAME TYPE))))
(COND (G (RETURN (%MAKEDEF NAME G TYPE))))
(AND F (GO A))
(COND (TRACED?
(%iog% TV
(%P '|function| NAME '|traced but not found, will untrace...|))
(APPLY 'UNTRACE (NCONS NAME))
(SETQ F H TRACED? NIL)
(GO A)))
(%iog% TV
(%P '|function| NAME '|not found?|))
(RETURN NIL)))
(DEFUN %MAKEDEF (NAME EXP TYPE)
(COND ((MEMQ TYPE '(EXPR FEXPR LEXPR MACRO))
(CONS 'DEFUN
(CONS NAME
(COND ((EQ TYPE 'EXPR)
(COPY (CDR EXP)))
((CONS TYPE (COPY (CDR EXP))))))))
((LIST 'DEFPROP NAME EXP TYPE))))
(DEFUN %GETDEF1 (NAME)
;; looks for definition of function "name" as a draft copy
;; or the current ce.
(COND ((EQ NAME (%GETNAME %TOP-EDIT-EXP)) %TOP-EDIT-EXP)
((GET NAME 'DRAFT))))
;;*page
;;;;;;;;;; functions for replacing forms ;;;;;;;;;;
(DECLARE (SPECIAL %REPLACE-FLAG))
(DEFUN %SUBSTITUTE (A B L)
;; like subst, but uses rplaca & rplacd.
(COND ((EQUAL A L)(SETQ %REPLACE-FLAG T) (COPY B))
((ATOM L) L)
(T (AND (CDR L) (RPLACD L (%SUBSTITUTE A B (CDR L))))
(RPLACA L (%SUBSTITUTE A B (CAR L))))))
(DEFUN %LSUBSTITUTE (A B L)
;; like %substitute, but operates on list structure, not tree structure
(COND ((EQUAL A L) (SETQ %REPLACE-FLAG T) (COPY B))
((ATOM L) L)
(T (AND (CDR L) (%LSUBSTITUTE A B (CDR L)))
(RPLACA L (%LSUBSTITUTE A B (CAR L))))))
(DECLARE (UNSPECIAL %REPLACE-FLAG))
(DEFUN %CREPLACE (L)
;; splices the list L in where the CE was.
(PROG (N)
(RETURN (COND ((SETQ N (%ASCEND))
(%REPLACE L N)
(%DESCEND N))
((NULL %/#CHAIN)
(SETQ %/#CE (CAR L) %TOP-EDIT-EXP %/#CE)
T)))))
(DEFUN %REPLACE (L N)
;; the nth element of the ce is replaced by splicing in the list L.
(%AINSERT L N)
(%DELETE N))
(DECLARE (SPECIAL *1 *2))
(DEFUN %STRINGSUB (OLDLIST NEWLIST WORD)
(PROG (*1 *2)
(RETURN
(AND
(%MATCH (APPEND '(*1) OLDLIST '(*2))
(APPEND '($$$)
(EXPLODE WORD)
'($$$)))
(READLIST
(REVERSE (CDR (REVERSE (CDR (APPEND *1
NEWLIST
*2))))))))))
;;*page
;;;;;;;;;; functions for reforming the ce ;;;;;;;;;;
(DEFUN %MRPI NIL
;;; move right paren in.
;;; i.e. the last element of the ce is deleted and then inserted
;;; as the ce's right-brother.
;;; returns nil iff the ce is an atom or has no father.
(PROG (TEMP N)
(OR (AND (NOT (ATOM %/#CE)) (SETQ N (CDAR %/#CHAIN)))
(RETURN NIL))
(SETQ TEMP (LAST %/#CE))
(%DELETE (%LENGTH %/#CE))
(%ASCEND)
(%AINSERT TEMP N)
(RETURN (%DESCEND N))))
(DEFUN %MRPO NIL
;;; move right paren out.
(PROG (TEMP N)
(OR (AND (SETQ N (CDAR %/#CHAIN))
(< N (%LENGTH (CAAR %/#CHAIN))))
(RETURN NIL))
(%ASCEND)
(SETQ TEMP (%CARN %/#CE (1+ N)))
(%DELETE (1+ N))
(%DESCEND N)
(RETURN (%AINSERT (NCONS TEMP) (%LENGTH %/#CE)))))
(DEFUN %MLPI NIL
;; move left paren in.
(PROG (TEMP N)
(OR (SETQ N (CDAR %/#CHAIN)) (RETURN NIL))
(SETQ TEMP (CAR %/#CE))
(%DELETE 1.)
(%ASCEND)
(%BINSERT (NCONS TEMP) N)
(RETURN (%DESCEND (1+ N)))))
(DEFUN %MLPO NIL
;; move left paren out.
(PROG (TEMP N)
(OR (AND (SETQ N (CDAR %/#CHAIN)) (> N 1.)) (RETURN NIL))
(%ASCEND)
(SETQ TEMP (%CARN %/#CE (1- N)))
(%DELETE (1- N))
(%DESCEND (1- N))
(RETURN (%BINSERT (NCONS TEMP) 1.))))
;;*page
;;;;;;;;;;;;;;;;;;;;;;;searching functions;;;;;;;;;;;;;;;;;;
;;; %find:
;;; pat : pattern to search for.
;;; dir = -1 : search backwards.
;;; = +1 : search forwards.
;;; mode = t : check immediate sons first
;;; = top : check only immediate sons
;;; = +<n> : find the nth occurance of pattern
(DEFUN %FIND (PAT DIR MODE)
(SETQ %LAST-FIND-PATTERN PAT)
(COND ((EQ MODE 'TOP)(%TOPCHECK PAT DIR))
((EQ MODE T) (OR (%TOPCHECK PAT DIR) (%FIND1 PAT DIR)))
((%POS MODE)
(DO NIL
((= MODE 0.) T)
(OR (%FIND1 PAT DIR) (RETURN NIL))
(SETQ MODE (1- MODE))))))
;;; %find1 searches for next occurance of <pat> starting from %/#ce
;;; if d=+1 then search to right
;;; d=-1 then search to left
;;; first searches the ce, then everything to its right.
;;; i.e. searches in print order.
(DEFUN %FIND1 (PAT D)
(DECLARE (FIXNUM D))
(OR (%CHECK-ELEMENTS PAT
(COND ((PLUSP D) 1.) ((%LENGTH %/#CE)))
D)
(%CHECK-UPWARDS PAT D)))
(DEFUN %CHECK-EXPRESSION (PAT D)
;; check expression and its elements.
(DECLARE (FIXNUM D))
(OR (%MATCH PAT %/#CE)
(%CHECK-ELEMENTS PAT
(COND ((PLUSP D) 1.) ((%LENGTH %/#CE)))
D)))
(DEFUN %CHECK-ELEMENTS (PAT I D)
;; check elements of expression.
(DECLARE (FIXNUM I D))
(DO NIL
((NOT (%DESCEND I)) NIL)
(COND ((%CHECK-EXPRESSION PAT D) (RETURN T))
((%ASCEND) (SETQ I (+ I D))))))
(DEFUN %CHECK-UPWARDS (PAT D)
;; climb up the tree searching for pat.
(DECLARE (FIXNUM D N))
(PROG (N)
(SETQ N (CDAR %/#CHAIN))
(RETURN (AND (%ASCEND)
(OR (%CHECK-ELEMENTS PAT (+ N D) D)
(%CHECK-UPWARDS PAT D)
(AND (%DESCEND N) NIL))))))
;;; search the top-level elements of the ce for pattern.
;;; d = +1 : forward search
;;; d = -1 : backward search
(DEFUN %TOPCHECK (PAT D)
(DECLARE (FIXNUM D START STOP))
(PROG (START STOP)
(COND ((> D 0.) (SETQ START 1. STOP (1+ (%LENGTH %/#CE))))
((SETQ START (%LENGTH %/#CE) STOP 0.)))
(RETURN (DO ((J START (+ J D)))
((= J STOP) NIL)
(AND (%MATCH PAT (%CARN %/#CE J))
(%DESCEND J)
(RETURN T))))))
;;*page
;;;;;;;;;; the matching function ;;;;;;;;;;
;;;
;;; (arg 1) - p - pattern
;;; (arg 2) - d - data
;;; (arg 3) - alist - optional list of variables (* or ?) whose values
;;; are to be retained during the match, much like the
;;; = variables below.
;;; elements of a pattern:
;;; ? - matches anything
;;; * - matches one or more expressions
;;; ?<atom> - like "?", but sets ?<atom> to thing matched
;;; *<atom> - like "*", but sets *<atom> to list of things matched
;;; =<atom> - matched against value of <atom>
;;; (restrict <one of above ?-variables> <pred1> <pred2> .....)
;;; - the predi must eval to non-nil
;;;
;;; (%match p d <variables to retain>) attempts to match p against d
;;; (%continue-match p d <variables to retain>) attempts to get the next
;;; possible match between p and d (by different *-variable
;;; bindings.
;;; *page
;;; The Matcher & friends normally appear in this slot.
;;; However, they are now in MATCH.nnn[AID,RPG] so that they
;;; can be loaded separately. Note the AUTOLOADs below
;;;
[IFN SAIL
(DEFPROP %MATCH (MATCH FAS DSK (MAC LSP)) AUTOLOAD)
; (DEFPROP %CHAR1 (MATCH FAS DSK (MAC LSP)) AUTOLOAD)
(DEFPROP %CONTINUE-MATCH (MATCH FAS DSK (MAC LSP)) AUTOLOAD)
(DEFPROP %%MATCH (MATCH FAS DSK (MAC LSP)) AUTOLOAD)]
[IFN ITS
(DEFPROP %MATCH (RPGMATCH FASL DSK JONL) AUTOLOAD)
; (DEFPROP %CHAR1 (RPGMATCH FASL DSK JONL) AUTOLOAD)
(DEFPROP %CONTINUE-MATCH (RPGMATCH FASL DSK JONL) AUTOLOAD)
(DEFPROP %%MATCH (RPGMATCH FASL DSK JONL) AUTOLOAD)]
[IFN ((NOT SAIL) DEC10)
(DEFPROP %MATCH (MATCH FAS SYS (1 2)) AUTOLOAD)
; (DEFPROP %CHAR1 (MATCH FAS SYS (1 2)) AUTOLOAD)
(DEFPROP %CONTINUE-MATCH (MATCH FAS SYS (1 2)) AUTOLOAD)
(DEFPROP %%MATCH (MATCH FAS SYS (1 2)) AUTOLOAD)]
;;*page
;;;;;;;;;; marking functions ;;;;;;;;;;
(DEFUN %MARK NIL
;; set the mark to the ce.
(SETQ %MARKCHAIN (NREVERSE (MAPCAR (FUNCTION CDR) %/#CHAIN))
%MARKCHAINLENGTH (LENGTH %MARKCHAIN)))
(DEFUN %JUMP NIL
;; jump to the last place the mark was set.
(PROG (CE CHAIN)
(SETQ CE %/#CE CHAIN %/#CHAIN)
(RETURN
(COND (%MARKCHAIN (SETQ %/#CE %TOP-EDIT-EXP %/#CHAIN NIL)
(DO ((MCH %MARKCHAIN (CDR MCH)))
((NULL MCH) T)
(COND ((%DESCEND (CAR MCH)))
(T (SETQ %/#CHAIN CHAIN
%/#CE CE)
(BEEP)
(%P '|can't find mark|)
(RETURN NIL)))))
(T (%P '|mark has not been set|) (BEEP) NIL)))))
(DEFUN %REMARK (POS N)
;; update the mark. called by %ainsert and %delete.
(PROG (MCH)
(AND %MARKCHAIN
(NOT (> (LENGTH %/#CHAIN) %MARKCHAINLENGTH))
(SETQ MCH
(DO ((CH (NREVERSE (MAPCAR (FUNCTION CDR)
%/#CHAIN))
(CDR CH))
(MCH %MARKCHAIN (CDR MCH)))
((NULL (CDR CH)) MCH)
(OR (= (CAR CH) (CAR MCH)) (RETURN NIL))))
(COND ((> POS (CAR MCH)) N)
((= POS (CAR MCH))
(AND (< N 0.) (SETQ %MARKCHAIN NIL)))
((RPLACA MCH (+ (CAR MCH) N)))))
(RETURN T)))
;;*page
;;;;;; utility functions ;;;;;;;;;;
[IFN SAIL
(MACRODEF NEXT-SYM () (IMPLODE (CONS '? (EXPLODEC (SETQ %%NEXT-SYM%%
(1+ %%NEXT-SYM%%))))))
(MACRODEF NEXT-SYM*()(IMPLODE (CONS '* (EXPLODEC %%NEXT-SYM%%))))
(DEFUN %STRUCTURE-LS (EXP N)
;;; %structure returns exp with all parts with depth > n
;;; replaced by "/#".
(DECLARE (FIXNUM N))
(COND ((ATOM EXP) EXP)
((ZEROP N) ((LAMBDA(Q)
(SET (INTERN (NEXT-SYM*)) EXP)
(PROG2 (SET Q EXP) Q))
(INTERN (NEXT-SYM))))
(T (CONS (%STRUCTURE-LS (CAR EXP) (1- N))
(%STRUCTURE-LS (CDR EXP) N)))))]
(DEFUN %STRUCTURE (EXP N)
;;; %structure returns exp with all parts with depth > n
;;; replaced by "⊗".
(DECLARE (FIXNUM N))
(COND ((ATOM EXP) EXP)
((ZEROP N) '⊗)
((HUNKP EXP)
((LAMBDA (H J N-1)
(SETQ H (MAKHUNK J))
(DO ((I 0 (1+ I)))
((= I J) H)
(RPLACX I H (%STRUCTURE (CXR I EXP) N-1))))
()(HUNKSIZE EXP)(1- N)))
(T (CONS (%STRUCTURE (CAR EXP) (1- N))
(%STRUCTURE (CDR EXP) N)))))
(DEFUN %SPRINT (EXP)
((LAMBDA (REMSEMI SPOINTER)
(COND (SPOINTER)
(T ((LAMBDA (C)
(FASLOAD GRINDEF FAS DSK (MAC LSP))
(SETQ SPOINTER (GET 'SPRINTER 'SUBR))
(APPLY 'CRUNIT C))
(CRUNIT))))
(SUBRCALL NIL SPOINTER EXP) (TYO 32.)) %COMMENTS? (GET 'SPRINTER 'SUBR)))
(DEFUN %LENGTH (L)
;; (%length <atom>) ==> 0.
(DECLARE (FIXNUM I))
(COND ((ATOM L) 0.) (T (DO ((I 0 (1+ I))
(L L (CDR L)))
((ATOM L) I)))))
(DEFUN %CARN (L N)
;; returns nth element of the list L.
(DECLARE (FIXNUM N))
(DO ((I N (1- I))) ((< I 2.) (CAR L)) (SETQ L (CDR L))))
(DEFUN %CDRN (L N)
;; returns the nth cdr of the list L.
(DECLARE (FIXNUM N))
(DO ((I N (1- I))) ((= 0. I) L) (SETQ L (CDR L))))
(DEFUN %POS (N) (AND (NUMBERP N) (< 0. N)))
(DEFUN %NEG (N) (AND (NUMBERP N) (< N 0.)))
(DEFUN %P N
;; a printing function.
(TERPRI)
(DO ((X 1. (1+ X)))
((> X N) T)
(MAPC (FUNCTION (LAMBDA (LIST) (PRINC LIST) (TYO 32.)))
(COND ((ATOM (ARG X)) (NCONS (ARG X))) ((ARG X))))))
;;*page
;;;;;;;;;; functions for reading & writing on dsk ;;;;;;;;;;;;;;;
;;;
(DEFUN %READF (F-NAME FILE)
;; gets the definition of the function F-NAME out of the
;; FILE. returns nil iff the file is not found, or the function
;; is not in the file.
(PROG (S READTABLE EOF)
(SETQ READTABLE (COND (%COMMENTS? GRINDREADTABLE)
(T (GET 'READTABLE
'ARRAY)))
EOF (LIST NIL))
(SETQ FILE (%EXPAND-FILE-NAME FILE))
(COND ((APPLY 'UPROBE FILE)
(APPLY (COND ((STATUS FEATURE SAIL)'EREAD)
(T 'UREAD)) FILE))
(T (%P '|file not found: | FILE)
(RETURN NIL)))
(SETQ ↑Q T)
LOOP (COND ((EQ EOF (SETQ S (READ EOF)))
(COND ((STATUS FEATURE SAIL) (BEEP)))
(%P '|the function:|
F-NAME
'|was not in the file:|
FILE)
(RETURN NIL))
((%MATCH F-NAME (%GETNAME S))
(SETQ ↑Q NIL)
(PUTPROP F-NAME FILE '%SOURCEFILE)
(RETURN S)))
(GO LOOP)))
(macrodef push-f (x) (setq pdl (cons x pdl)))
(macrodef pop-f () (setq specs (cdr specs)))
(macrodef check () (cond ((null specs)(*throw 'out (nreverse pdl)))))
(macrodef default (file)
(cond (file
(*catch 'out
(prog (pdl)
(push-f (car file))
(pop-f)
(push-f (cond ((or (null file)
(memq (car file) '(dsk sys))
(not (atom (car file)))) '/ )
(t (prog2 nil (car file) (pop-f)))))
(check)
(push-f (cond ((atom (car file)) (prog2 nil (car file)(pop-f)))
(t 'dsk)))
(check)
(push-f (cond ((= (length (car file)) 2)(car file))
(t (list (caar file)(cadr (status udir))))))
(*throw 'out (nreverse pdl)))
))))
(DEFUN %EXPAND-FILE-NAME (SPECS)
;; specs = (filename ext) or ((filename ext)). Extension
;; defaults to LSP.
(AND (NULL (CDR SPECS))
(NOT (ATOM (CAR SPECS)))
(SETQ SPECS (CAR SPECS)))
;; default extension?
(COND ((STATUS FEATURE SAIL)(SETQ SPECS (DEFAULT SPECS)))
(T
(OR (CDR SPECS)
(SETQ SPECS (LIST (CAR SPECS)
(IMPCOND (SAIL '/ )
(DEC10 'LSP)
(ITS '>)))))))
;; default device and PPN?
(OR (CDDR SPECS) (SETQ SPECS (APPEND SPECS (CRUNIT))))
(OR (CDDDR SPECS) (SETQ SPECS (APPEND SPECS (CDR (CRUNIT)))))
(AND (STATUS FEATURES SAIL)
(COND ((EQ (CADR SPECS) '/>)
(RPLACA (CDR SPECS)
(APPLY 'UGREAT
(LIST (CAR SPECS)
(CAR (CADDDR SPECS))
(CADR (CADDDR SPECS))))))))
SPECS)))
[IFN SAIL
[IFN NEWIO
(DEFPROP UGREAT (DIRECT FAS DSK (MAC LSP)) AUTOLOAD)]
[IFE NEWIO
(DEFPROP UGREAT (DIRECT FAS DSK (OLD LSP)) AUTOLOAD)]]
(DEFUN %WRITEF (EXP FILE)
;; sprints the form EXP into a file FILE.
(PROG NIL
(SETQ FILE (%EXPAND-FILE-NAME FILE))]
; [IFE NEWIO
; (SETQ FILE (%EXPAND-FILE-NAME FILE))]
; [IFN NEWIO
; (SETQ FILE (CONS (CADR FILE) (CONS
; (CADDR FILE) (CAR FILE))))]
(COND ((APPLY 'UPROBE FILE)
(APPLY 'UAPPEND FILE))
(T (APPLY 'UWRITE (CDDR FILE))))
(COND ((APPLY 'UPROBE FILE)
(APPLY 'UAPPEND FILE))
(T (APPLY 'UWRITE (CDDR FILE))))]
;; get the grinder
(%GETGRIND)
(%iog% WR (%SPRINT EXP))
(RETURN (APPLY '%UFILE
(LIST (CAR FILE) (CADR FILE))))))
(DECLARE (SPECIAL *FILE *EXT *P *PN) (*LEXPR %MATCH))
(DEFUN %READ-FILE-NAME (MESSAGE)
(TERPRI)
(AND MESSAGE (PRINC MESSAGE) (TYO 32.))
((LAMBDA (SYN1 SYN2 SYN3 SYN4 MAC1 MAC2 MAC3 MAC4)
(SETSYNTAX 44. 2 44.)
(SETSYNTAX 46. 2 46.)
(SETSYNTAX 91. 2 91.)
(SETSYNTAX 93. 2 93.)
((LAMBDA (X *FILE *EXT *P *PN)
(COND
((EQ X 'QUIT) (↑G))
(T
((LAMBDA (Q)
(COND ((%MATCH '(*FILE |.| *EXT /[ *P /, *PN ]
*) Q)
(LIST (LIST 'DSK
(LIST (IMPLODE *P)
(IMPLODE *PN)))
(IMPLODE *FILE)
(IMPLODE *EXT)))
((%MATCH '(*FILE |.| *EXT /[ *P /, *)
Q)
(LIST (LIST 'DSK
(LIST (IMPLODE *P)
(CADR (STATUS UDIR))))
(IMPLODE *FILE)
(IMPLODE *EXT)))
((%MATCH '(*FILE |.| *EXT /[ *P) Q)
(LIST (LIST 'DSK
(LIST (IMPLODE *P)
(CADR (STATUS UDIR))))
(IMPLODE *FILE)
(IMPLODE *EXT)))
((%MATCH '(*FILE |.| *EXT /[) Q)
(LIST (LIST 'DSK (STATUS UDIR))
(IMPLODE *FILE)
(IMPLODE *EXT)))
((%MATCH '(*FILE |.| *EXT) Q)
(LIST (LIST 'DSK (STATUS UDIR))
(IMPLODE *FILE)
(IMPLODE *EXT)))
((%MATCH '(*FILE) Q) X)
(T (%READ-FILE-NAME '|Guess again!!!|))))
((LAMBDA (L)
((LAMBDA (AA BB)
(DO NIL
((NOT BB))
(SETQ AA (CDR AA) BB (CDR BB)))
(RPLACD AA NIL)
L)
L
(CDDR L)))
(CDR (EXPLODE X)))))))
(UNWIND-PROTECT (READ)
(SETSYNTAX 44. SYN1 44.)
(SETSYNTAX 46. SYN2 46.)
(SETSYNTAX 91. SYN3 91.)
(SETSYNTAX 93. SYN4 93.)
(AND MAC1 (SSTATUS MACRO 44. (CAR MAC1)))
(AND MAC2 (SSTATUS MACRO 46. (CAR MAC2)))
(AND MAC3 (SSTATUS MACRO 91. (CAR MAC3)))
(AND MAC4 (SSTATUS MACRO 93. (CAR MAC4))))
NIL
NIL
NIL
NIL))
(STATUS SYNTAX 44.)
(STATUS SYNTAX 46.)
(STATUS SYNTAX 91.)
(STATUS SYNTAX 93.)
(STATUS MACRO 44.)
(STATUS MACRO 46.)
(STATUS MACRO 91.)
(STATUS MACRO 93.)))
;(DEFUN %READ-FILE-NAME NIL
; (DO ((I (TYIPEEK) (TYIPEEK)))
; ((AND (NOT (= I 12)) (NOT (= I 15))))
; (TYI))
; (COND ((NOT (= (TYIPEEK) 50)) (%PARSE-FILENAME)) (T (READ))))
;(DEFUN %PARSE-FILENAME NIL
; ((LAMBDA (PER COM LB RB)
; (SETSYNTAX '/.
; 'SPLICING
; '(LAMBDA NIL (NCONS (ASCII 32.))))
; (SETSYNTAX '/[
; 'SPLICING
; '(LAMBDA NIL (NCONS (ASCII 32.))))
; (SETSYNTAX '/,
; 'SPLICING
; '(LAMBDA NIL (NCONS (ASCII 32.))))
; (SETSYNTAX '/]
; 'SPLICING
; '(LAMBDA NIL (NCONS (ASCII 32.))))
; (PROG2 NIL
; ((LAMBDA(A)(COND ((NOT (= (TYIPEEK) 15))
; (APPEND A (LIST 'DSK (LIST (READ)(READ)))))
; (T A)))
; (LIST (READ)(READ)))
; (SETSYNTAX '/. PER NIL)
; (SETSYNTAX '/, COM NIL)
; (SETSYNTAX '/[ LB NIL)
; (SETSYNTAX '/] RB NIL)))
; (STATUS SYNTAX 46.)
; (STATUS SYNTAX 44.)
; (STATUS SYNTAX 91.)
; (STATUS SYNTAX 93.)))
(DECLARE (SPECIAL TO-REFILE REFILE-ALL UPDATED))
(DEFUN %REFILE (TO-REFILE %INFILE OUTFILE)
;; updates function definitions in a file. to-refile is a
;; function name or a list of function names. "*" acts as a wildcard
;; which matches any function. If it is included, then for each
;; function definition in the file, we look for a draft copy.
;; If found, then we replace the old copy with the draft.
;; if a function is explicitly named, then we look for a draft copy
;; and, if none is found, we look for an executable copy.
;; any function definitions not found in the file are
;; appended to the bottom of the file.
;; if outfile is nil, it defaults to %INFILE.
;; if %INFILE is not specified, we attempt to find a %sourcefile property for one of the functions
(PROG (REFILE-ALL UPDATED S NEW GFLAG)
;; ensure that to-refile is a list.
(AND (ATOM TO-REFILE) (SETQ TO-REFILE (NCONS TO-REFILE)))
;; look for a "wildcard"
(AND (MEMQ '* TO-REFILE)
(SETQ REFILE-ALL T)
(SETQ TO-REFILE (DELQ '* TO-REFILE)))
;; determine the input file.
(SETQ GFLAG (EQ (CADR %INFILE) '/>))
(COND (%INFILE (SETQ %INFILE (%EXPAND-FILE-NAME %INFILE)))
((%GET-SOURCE-FILE TO-REFILE))
(T (%P '|please specify a file.|)
(RETURN NIL)))
;; determine the output file.
(SETQ OUTFILE
(COND (OUTFILE ((LAMBDA (FILE)
(COND ((EQ (CADR OUTFILE) '/>)
(RPLACA (CDR FILE)
(IMPLODE
(EXPLODE
(1+ (READLIST (NCONS
(CADR FILE))))))))
(T FILE)))
(%EXPAND-FILE-NAME OUTFILE)))
(T (COND (GFLAG (CONS (CAR %INFILE)
(CONS (IMPLODE
(EXPLODE
(1+ (READLIST (NCONS
(CADR %INFILE))))))
(CDDR %INFILE))))
(T %INFILE)))))
;; get the grinder if it isn't already here
(%getgrind)
;; open the file for output.
(SETQ ↑R T)
;; here we go!
[IFN NEWIO
(COND ((PROBEF (NAMELIST %INFILE))
(%ACTIVATE-GRIND-MACROS T)
(APPLY 'GRIND0 %INFILE)
(%ACTIVATE-GRIND-MACROS NIL))
(t (APPLY 'UWRITE (CDDR OUTFILE))))
]
[IFE NEWIO
(COND ((APPLY 'UPROBE %INFILE)
(%ACTIVATE-GRIND-MACROS T)
(APPLY 'GRIND0 %INFILE)
(%ACTIVATE-GRIND-MACROS NIL))
(t (APPLY 'UWRITE (CDDR OUTFILE))))
]
;; add new functions.
[IFN NEWIO
(COND ((MEMQ UWRITE OUTFILES))
(T (PUSH UWRITE OUTFILES)))]
(%iog%
WR
(MAPC (FUNCTION (LAMBDA (F)
(COND ((SETQ S (%GETDEF F))
(PUSH F NEW)
(SETQ TO-REFILE
(DELQ F TO-REFILE))
(%SPRINT S)))))
TO-REFILE))
;; close the file.
(APPLY '%UFILE OUTFILE)
;; tell the user what happened.
(AND UPDATED
(%iog% TV
(%P '|updated functions are:|
UPDATED)))
(AND NEW
(%iog% TV (%P '|new functions added:| NEW)))
(AND TO-REFILE
(%iog% TV
(%P '|unknown functions:| TO-REFILE)))
;; return the file name.
(RETURN OUTFILE)))
(DEFUN %GETGRIND NIL
;; make sure GRIND is in.
(AND (OR (GET 'GRINDEF 'FSUBR)
((LAMBDA (C)
[IFN SAIL (FASLOAD GRINDE FAS DSK (MAC LSP))]
[IFN ITS (FASLOAD GRINDEF FASL COM)]
[IFN ((NOT SAIL) DEC10) (FASLOAD GRINDE FAS SYS (1 2 ))]
(APPLY 'CRUNIT C))(CRUNIT)))
(OR (STATUS FEATURE GRIND)
((LAMBDA (C)
[IFN SAIL (FASLOAD GRIND FAS DSK (MAC LSP))]
[IFN ITS (FASLOAD GRIND FASL COM)]
[IFN ((NOT SAIL) DEC10) (FASLOAD GRIND FAS SYS (1 2 ))]
(APPLY 'CRUNIT C))(CRUNIT)))))
(DEFUN %GET-SOURCE-FILE (FUNCTIONS)
;; scans the list of functions looking for a sourcefile.
(DO ((F))
((NULL FUNCTIONS) NIL)
(COND ((SETQ F (GET (CAR FUNCTIONS) '%SOURCEFILE))
(RETURN F))
(T (SETQ FUNCTIONS (CDR FUNCTIONS))))))
(DECLARE (UNSPECIAL TO-REFILE REFILE-ALL UPDATED))
(DEFUN %ACTIVATE-GRIND-MACROS (X)
(COND (X (APPLY 'GRINDMACRO
(LIST (APPEND %EDITFUNCTIONS
'(DEFUN DEFPROP))
'%EDIT-GRIND-MACRO)))
(T (MAPC
(FUNCTION (LAMBDA (F)
(REMPROP F 'GRINDMACRO)))
(APPEND %EDITFUNCTIONS '(DEFUN DEFPROP))))))
(DECLARE (SPECIAL L TO-REFILE REFILE-ALL UPDATED))
(DEFUN %EDIT-GRIND-MACRO NIL
;; l is a special grind variable which is set to the current
;; expression being ground. note: we always return nil. if l is
;; a function definition and %GETDEF finds an edited version of it,
;; L is set to the latest version.
(PROG (NAME X)
(SETQ NAME (%GETNAME L))
(AND (COND ((MEMQ NAME TO-REFILE)
(SETQ X (%GETDEF NAME)))
(REFILE-ALL (SETQ X (%GETDEF1 NAME))))
(PUSH NAME UPDATED)
(SETQ L X TO-REFILE (DELETE NAME TO-REFILE)))))
(DECLARE (UNSPECIAL L TO-REFILE REFILE-ALL UPDATED))
;;*page
(DEFUN %FLUSHCOMMENTS (L)
(COND ((AND (BOUNDP '|;;|)
(MEMQ (CAR L) '(DEFUN DEFINE)))
(CAR (%FLUSHCOMMENTS1 L))) (L)))
(DEFUN %FLUSHCOMMENTS1 (L)
(COND ((ATOM L) (NCONS L))
((OR (EQ (CAR L) /;) (EQ (CAR L) |;;|)) NIL)
((EQ (CAR L) 'QUOTE)(NCONS L))
(T (NCONS (APPLY 'NCONC
(MAPCAR (FUNCTION %FLUSHCOMMENTS1)
L))))))
(DEFUN EDITCOMMAND FEXPR (X)
;; defines atomic edit commands. e.g.: (editcommand ↑↑
;;(%ascend)(%ascend))
(PUTPROP (CAR X)
(CONS 'PROGN (CDR X))
'ATOMIC-EDITCOMMAND)
(CAR X))
(DEFUN %LOAD-EDIT-INIT-FILE NIL
(PROG (FILE CRUNIT)
(SETQ %INITIALIZE-EDITOR? NIL)
(OR (SETQ FILE (GET 'EDIT 'EDIT-INIT-FILE))
(RETURN NIL))
(SETQ CRUNIT (CRUNIT))
(%P (get 'edit 'edit-init-file-load-message))
((LAMBDA(READTABLE)
(%LOAD-EDIT-INIT FILE 0.))
%EDITREADTABLE)
;; flush these useless functions.
[IFE SAIL
(REMPROP '%LOAD-EDIT-INIT-FILE 'SUBR)
(REMPROP '%LOAD-EDIT-INIT 'SUBR)]
;; restore crunit for the user.
(APPLY 'CRUNIT CRUNIT)))
(DEFUN %LOAD-EDIT-INIT (FILE /#TOSKIP)
;; the /#toskip hack enables EDIT.INI files to contain "links" to other EDIT.INI files.
(PROG (EOF)
(COND ((APPLY 'UPROBE FILE)
(APPLY [IFN SAIL 'EREAD]
[IFE SAIL 'UREAD] FILE))
(T (RETURN NIL)))
(SETQ ↑Q T EOF (LIST NIL))
(DO ((EXP (READ EOF) (READ EOF)) (COUNT 0. (1+ COUNT)))
((EQ EXP EOF) T)
(COND ((< COUNT /#TOSKIP))
((EQ (CAR EXP) 'LINKTO)
(MAPC
(FUNCTION (LAMBDA (F)
(%LOAD-EDIT-INIT F 0.)))
(CDR EXP))
(RETURN (%LOAD-EDIT-INIT FILE (1+ COUNT))))
((EVAL EXP))))))
;; ha ha
(DEFUN %EDIT-HELP NIL
(COND ((GET 'WORKER 'SUBR))
(T
[IFN SAIL (FASLOAD DOCTOR FAS DSK (MAC LSP))]
[IFN ((NOT SAIL) DEC10) (FASLOAD DOCTOR FAS SYS (1 2))]
[IFN ITS (FASLOAD DOCTOR FAS JONL)]))
(%P
'|OK. Please enter your question followed by two <returns>.|)
(SETQ ERRLIST NIL)
(WORKER))
(DEFUN REMEDIT NIL
;; removes as many traces of the editor as possible.
(MAPATOMS 'REMEDITPROPS)
(MAPCAR (FUNCTION (LAMBDA (Q) (REMPROP Q 'ARGS)
(OR (REMPROP Q 'SUBR)
(REMPROP Q 'FSUBR)
(REMPROP Q 'LSUBR)
(REMPROP Q 'MACRO))))
(GET 'EDIT 'EDITFNS))
(REMPROP 'EDIT 'EDITFNS)
(MAPC (FUNCTION MAKUNBOUND)
(GET 'EDIT 'EDITVARIABLES))
(REMPROP 'EDIT 'EDITVARIABLES)
(SSTATUS NOFEATURE EDIT)
;; gc totaly useless atoms.
(GCTWA T)
;; reset top level
(COND ((STATUS TOPLEVEL) (SSTATUS TOPLEVEL NIL))
(T 'EDITOR-GONE)))
(DEFUN REMEDITPROPS (ATOM)
(REMPROP ATOM '%SOURCEFILE)
(REMPROP ATOM 'DRAFT)
(REMPROP ATOM 'LIST-EDITCOMMAND)
(REMPROP ATOM 'ATOMIC-EDITCOMMAND))
;; a list of all the functions in this file.
(DEFPROP EDIT
(REMEDIT %EDIT-HELP
%EDIT1
%EDIT5
%EDIT6
%EDIT-LOAD-MSG
%EVAL-LIST
%EVAL-ATOM
%EVAL-NUMBER
EDITCOMMAND
%LOAD-EDIT-INIT
%ACINSERT
%AINSERT
%ASCEND
%BCINSERT
%BEFORE
%BINSERT
%CARN
%CDELETE
%CDRN
%CHECK-ELEMENTS
%CHECK-EXPRESSION
%CHPRINC
%CHECK-UPWARDS
%CREPLACE
%DATA-INIT
%DELETE
%DELETER
%DESCEND
%EDMACRO
%EVALUATE
%FIND
%GETDEF
%INSTANTIATE
%LENGTH
%MATCH
%%MATCH
%CONTINUE-MATCH
%MLPI
%MLPO
%MRPI
%MRPO
%NEG
%NEXT
%POP
%POS
%READF
%READ-FILE-NAME
%PARSE-FILENAME
%REPLACE
%LSUBSTITUTE
%SUBSTITUTE
%SPRINT
%STRINGSUB
%STRUCTURE
%TOPCHECK
%EDITORTOPLEVEL
%UNDOA
%SAVEMARK
%UNDOKSET
%RESTORE-STATE
%WRITEF
EDIT
RE-EDIT
%GETNAME
%WINDOW
%WINDOW-BACK
%WINDOW-FORWARD
%GETNAME
%MAKEDEF
%REFILE
%GETGRIND
%ACTIVATE-GRIND-MACROS
%FLUSHCOMMENTS
%FLUSHCOMMENTS1
%TOUNDO:
EDIT1
EDIT2
BEDIT
BEXIT
%JUMP
%MARK
%REMARK
; %CHAR1
%EDMACRO
COPY)
EDITFNS)
(DEFPROP EDIT
(%/#CE %TOP-EDIT-EXP
←
%/#CHAIN
%/#UNDOFLAG
%/#UNDOLIST
%UNDOQLENGTH
%EDITREADTABLE
%STANDARDREADTABLE
%EDITFUNCTIONS
%LAST-FIND-PATTERN
%LAST-PATTERN
%LAST-CONTINUE-STACK
%LAST-SAVE-FILE
%/#RETAIN
%EDIT-PRINDEPTH
%EDIT-PRINLENGTH
%MARKCHAIN
%MARKCHAINLENGTH
?%PAT
?%X
?%X
?%Y
?CE
?%N)
EDITVARIABLES)
;; this must be the last s-expression in the file.
(PROG (FILE)
(SETQ FILE (LIST 'EDIT
(COND ((STATUS FEATURE DEC10) 'INI)
(T '|(init)|))
'DSK
(STATUS UDIR)))
(COND ((APPLY 'UPROBE FILE)
(TERPRI)
(putprop 'edit '|;loading EDIT.INI| 'edit-init-file-load-message)
(PUTPROP 'EDIT FILE 'EDIT-INIT-FILE)))
[IFN SAIL
(DEFPROP INITED (LOADED FAS DSK (MAC LSP)) AUTOLOAD)
(DEFPROP EREAD (EREAD FAS DSK (MAC LSP))
AUTOLOAD)
(DEFPROP BEEP (BEEP FAS DSK (MAC LSP))
AUTOLOAD)]
(MAPC
(FUNCTION (LAMBDA (Q)
(PUTPROP Q T 'ATOMIC-EDITCOMMAND)))
'(UNDO P PS PP ↑ TOP RI RO LI LO NX BK BF DELETE F OK W
[IFN SAIL L LS ] MATCH REMATCH REMEMBER EXIT HELP MARK JUMP UNMARK SAVE))
(MAPC
(FUNCTION (LAMBDA (Q) (PUTPROP Q T 'LIST-EDITCOMMAND)))
'(UNDO COMMENT A B R PA PB PAI PBI PL PD PRA BF F
TR TPRA WINDOW
REMATCH SAVE REFILE CR PR MATCH AI BI))
(SSTATUS FEATURE EDIT))